home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / boxes / aboutbox / aboutbox.bas next >
BASIC Source File  |  1996-03-17  |  11KB  |  308 lines
  1. Attribute VB_Name = "AboutBox_Main"
  2. '
  3. ' *******************************************************************
  4. '
  5. ' Some code and files: 1996 by Gregory H. Bragg, SofTecH Development
  6. '                      1995 by David Warren, MMC Software
  7. ' Some of the Registry code is from the VB4 Setup Kit, SETUP1 files.
  8. '
  9. ' Originally published by PC Magazine. Ported over to
  10. ' 32 Bit VB4 by Gregory H. Bragg starting March 6, 1996
  11. '
  12. ' Original: October 6, 1993  By Neil J. Rubenking
  13. ' Revised:  March 17, 1996   By Gregory H. Bragg
  14. '
  15. ' Any program that includes this file must also include ABOUTBOX.FRM
  16. '
  17. ' *******************************************************************
  18. '
  19. Option Explicit
  20. '
  21. ' The AB_NO_xxxx constants are used to exclude informational lines
  22. ' from the About Box display.  You pass one or more of them, combined
  23. ' using OR, as the fourth last parameter to DisplayAboutBox.
  24. Public Const AB_NO_USER = &H1
  25. Public Const AB_NO_COMPANY = &H2
  26. Public Const AB_NO_WIN_VERSION = &H4
  27. Public Const AB_NO_VERSION_NUMBER = &H8
  28. Public Const AB_NO_BUILD_NUMBER = &H10
  29. Public Const AB_NO_CPU = &H20
  30. Public Const AB_NO_PHYSICAL = &H40
  31. Public Const AB_NO_PAGING = &H80
  32. Public Const AB_NO_VIRTUAL = &H100
  33. Public Const AB_NO_MEMLOAD = &H200
  34.  
  35. ' Public variable holds bit flags for excluded items
  36. Public Excl As Integer
  37.  
  38. ' GetSystemMetrics returns the size (in pixels) of various on-screen
  39. ' items.  There are many more SM_xxxx constants besides those defined
  40. ' below.  The About Box uses the sizes to set its position on screen.
  41. Declare Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
  42. Public Const SM_CYCAPTION = &H4
  43. Public Const SM_CYMENU = &HF
  44. Public Const SM_CXSIZE = &H1F
  45.  
  46. ' O/S Version Info structure
  47. ' Used to get the operating system version and platform information
  48. Type OSVERSIONINFO
  49.     dwOSVersionInfoSize As Long
  50.     dwMajorVersion      As Long
  51.     dwMinorVersion      As Long
  52.     dwBuildNumber       As Long
  53.     dwPlatformId        As Long
  54.     szCSDVersion        As String * 128
  55. End Type
  56. ' dwPlatformId defines for OSVERSIONINFO structure...
  57. Public Const VER_PLATFORM_WIN32s = 0
  58. Public Const VER_PLATFORM_WIN32_WINDOWS = 1
  59. Public Const VER_PLATFORM_WIN32_NT = 2
  60. ' and related Win API call...
  61. Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
  62.  
  63. ' System Info structure
  64. ' Used to get the amount and type of CPU information
  65. Type SYSTEM_INFO
  66.     dwOemID                     As Long
  67.     dwPageSize                  As Long
  68.     lpMinimumApplicationAddress As Long
  69.     lpMaximumApplicationAddress As Long
  70.     dwActiveProcessorMask       As Long
  71.     dwNumberOfProcessors        As Long
  72.     dwProcessorType             As Long
  73.     dwAllocationGranularity     As Long
  74.     dwReserved                  As Long
  75. End Type
  76. ' dwProcessorType defines for SYSTEM_INFO structure...
  77. Public Const PROCESSOR_INTEL_386 = 386
  78. Public Const PROCESSOR_INTEL_486 = 486
  79. Public Const PROCESSOR_INTEL_PENTIUM = 586
  80. Public Const PROCESSOR_MIPS_R2000 = 2000
  81. Public Const PROCESSOR_MIPS_R3000 = 3000
  82. Public Const PROCESSOR_MIPS_R4000 = 4000
  83. Public Const PROCESSOR_ALPHA_21064 = 21064
  84. ' and related Win API call...
  85. Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
  86.  
  87. ' Memory Status Info structure
  88. ' Used to get various system memory information
  89. Type MEMORYSTATUS
  90.     dwLength        As Long  ' sizeof(MEMORYSTATUS)
  91.     dwMemoryLoad    As Long  ' percent of memory in use (between 1 and 100)
  92.     dwTotalPhys     As Long  ' bytes of physical memory
  93.     dwAvailPhys     As Long  ' free physical memory bytes
  94.     dwTotalPageFile As Long  ' bytes of paging file
  95.     dwAvailPageFile As Long  ' free bytes of paging file
  96.     dwTotalVirtual  As Long  ' user bytes of address space
  97.     dwAvailVirtual  As Long  ' free user bytes
  98. End Type
  99. ' and related Win API call...
  100. Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
  101.  
  102. ' Registry manipulation API's for getting the User or Company name
  103. Declare Function OSRegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
  104. Declare Function OSRegCloseKey Lib "advapi32" Alias "RegCloseKey" (ByVal hKey As Long) As Long
  105. Declare Function OSRegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpszValueName As String, ByVal dwReserved As Long, lpdwType As Long, lpbData As Any, cbData As Long) As Long
  106. Public Const HKEY_LOCAL_MACHINE = &H80000002
  107. Public Const KEY_QUERY_VALUE = &H1
  108. Public Const ERROR_SUCCESS = 0&
  109. Public Const REG_SZ = 1
  110.  
  111.  
  112. Public Sub DisplayAboutBox(F As Form, ByVal ProgName As String, _
  113.                            ByVal Version, ByVal CoprDate, _
  114.                            ByVal CoprName As String, _
  115.                            ByVal Ex1 As String, ByVal Ex2 As String, _
  116.                            ByVal Exclude As Integer, ByVal Center As Boolean, _
  117.                            ByVal Fore As Long, ByVal Back As Long)
  118.                     
  119. ' Your program simply calls this function to display an about box.
  120. ' F         - the main form of the calling program, used to get an
  121. '             icon for display and to position the about box.
  122. ' ProgName  - program name, for caption and first line
  123. ' Version   - version number, displayed as 0.00
  124. ' CoprDate  - copyright year
  125. ' CoprName  - copyright holder's name
  126. ' Ex1       - extra data line 1 (optional)
  127. ' Ex2       - extra data line 2 (optional)
  128. ' Exclude   - used to exclude info from the about box.  AB_NO_xxxx
  129. '             constants are bit-flags for this parameter.  e.g. to
  130. '             exclude displaying User info and Company info,
  131. '             pass AB_NO_USER OR AB_NO_COMPANY
  132. ' Center    - if TRUE, About box is centered on screen; if FALSE, About
  133. '             box is displayed offset from calling window.
  134. ' Fore,Back - foreground and background colors for box; 0 to use default
  135.  
  136.   Screen.MousePointer = 11 'hourglass
  137.   Excl = Exclude
  138.   Load FAB
  139.   Dim N As Integer
  140.   If Fore Then
  141.     FAB.ForeColor = Fore
  142.     FAB.CoprLabel.ForeColor = Fore
  143.     FAB.NameLabel.ForeColor = Fore
  144.     FAB.SSPanel1.ForeColor = Fore
  145.     For N = 0 To 19
  146.       FAB.OptLabel(N).ForeColor = Fore
  147.     Next N
  148.   End If
  149.   If Back Then
  150.     FAB.BackColor = Back
  151.     FAB.CommandOK.BackColor = Back
  152.     FAB.CoprLabel.BackColor = Back
  153.     FAB.IconPicture.BackColor = Back
  154.     FAB.NameLabel.BackColor = Back
  155.     FAB.SSPanel1.BackColor = Back
  156.     For N = 0 To 19
  157.       FAB.OptLabel(N).BackColor = Back
  158.     Next N
  159.   End If
  160.   If Center Then
  161.     FAB.Left = (Screen.Width - FAB.Width) \ 2
  162.     FAB.Top = (Screen.Height - FAB.Height) \ 2
  163.   Else
  164.     ' Place the About box over the calling window, offset downward
  165.     ' and to the right
  166.     Dim tmp As Integer ' variable to keep lines of code from becoming TOO long
  167.     tmp = GetSystemMetrics(SM_CXSIZE)
  168.     FAB.Left = F.Left + tmp * Screen.TwipsPerPixelX
  169.     tmp = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYMENU)
  170.     FAB.Top = F.Top + tmp * Screen.TwipsPerPixelY
  171.     ' If about box now extends off the screen, move it back ON
  172.     If FAB.Left + FAB.Width > Screen.Width Then
  173.       FAB.Left = Screen.Width - (FAB.Width + 50)
  174.     End If
  175.     If FAB.Top + FAB.Height > Screen.Height Then
  176.       FAB.Top = Screen.Height - (FAB.Height + 50)
  177.     End If
  178.   End If
  179.   FAB.IconPicture.Picture = F.Icon
  180.   FAB.Caption = "About " & ProgName
  181.   Dim Temp As String ' variable to keep lines of code from becoming TOO long
  182.   Temp = ProgName & ", Version " & Format$(Version, "0.00")
  183.   FAB.NameLabel.Caption = Temp
  184.   Temp = "Copyright ⌐ " & CoprDate & " by " & CoprName
  185.   FAB.CoprLabel.Caption = Temp
  186.   If Ex1 = "" Then
  187.     EliminateLabel 0
  188.   Else
  189.     FAB.OptLabel(0).Caption = Ex1
  190.   End If
  191.   If Ex2 = "" Then
  192.     EliminateLabel 1
  193.   Else
  194.     FAB.OptLabel(1).Caption = Ex2
  195.   End If
  196.   Screen.MousePointer = 0 'default
  197.   FAB.Show vbModal
  198.   
  199. End Sub
  200.  
  201. Public Sub EliminateLabel(ByVal Which As Long)
  202.  
  203.     ' If one of the informational labels in the about box is not wanted,
  204.     ' make it invisible and move all the other labels up to fill in the
  205.     ' space.  Then shrink the form as well.
  206.   
  207.     FAB.OptLabel(Which).Visible = False
  208.     Dim N As Integer, H As Integer
  209.     H = FAB.OptLabel(0).Height
  210.     For N = Which + 1 To 19
  211.         FAB.OptLabel(N).Top = FAB.OptLabel(N).Top - H
  212.     Next N
  213.     FAB.Height = FAB.Height - H
  214.        
  215.     ' We must also reposition the command button so that
  216.     ' it isn't hidden by the shrunken FAB form...
  217.     FAB.CommandOK.Top = FAB.Height - (FAB.CommandOK.Height + H + 200)
  218.     FAB.CommandOK.Left = FAB.Width - (FAB.CommandOK.Width + 200)
  219.   
  220. End Sub
  221.  
  222.  
  223. '
  224. ' FUNCTION: RegQueryStringValue
  225. '
  226. ' Retrieves the string data for a named
  227. ' (strValueName = name) or unnamed (strValueName = "")
  228. ' value within a registry key.  If the named value
  229. ' exists, but its data is not a string, this function
  230. ' fails.
  231. '
  232. ' Returns: True on success, else False.
  233. '
  234. ' On success, strData is set to the string data value
  235. '
  236. Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String, strData As String) As Boolean
  237.  
  238.     Dim lResult As Long
  239.     Dim lValueType As Long
  240.     Dim strBuf As String
  241.     Dim lDataBufSize As Long
  242.     
  243.     RegQueryStringValue = False
  244.     On Error GoTo 0
  245.     ' Get length/data type
  246.     lResult = OSRegQueryValueEx(hKey, strValueName, 0&, lValueType, ByVal 0&, lDataBufSize)
  247.     If lResult = ERROR_SUCCESS Then
  248.         If lValueType = REG_SZ Then
  249.             strBuf = String(lDataBufSize, " ")
  250.             lResult = OSRegQueryValueEx(hKey, strValueName, 0&, 0&, ByVal strBuf, lDataBufSize)
  251.             If lResult = ERROR_SUCCESS Then
  252.                 RegQueryStringValue = True
  253.                 strData = StripTerminator(strBuf)
  254.             End If
  255.         End If
  256.     End If
  257.     
  258. End Function
  259.  
  260.  
  261. '
  262. '-----------------------------------------------------------
  263. ' FUNCTION: RegCloseKey
  264. '
  265. ' Closes an open registry key.
  266. '
  267. ' Returns: True on success, else False.
  268. '-----------------------------------------------------------
  269. '
  270. Function RegCloseKey(ByVal hKey As Long) As Boolean
  271.  
  272.     Dim lResult As Long
  273.     On Error GoTo 0
  274.     lResult = OSRegCloseKey(hKey)
  275.     RegCloseKey = (lResult = ERROR_SUCCESS)
  276.     
  277. End Function
  278.  
  279.  
  280. '
  281. '-----------------------------------------------------------
  282. ' FUNCTION: StripTerminator
  283. '
  284. ' Returns a string without any zero terminator.  Typically,
  285. ' this was a string returned by a Windows API call.
  286. '
  287. ' IN: [strString] - String to remove terminator from
  288. '
  289. ' Returns: The value of the string passed in minus any
  290. '          terminating zero.
  291. '-----------------------------------------------------------
  292. '
  293. Function StripTerminator(ByVal strString As String) As String
  294.     
  295.     Dim intZeroPos As Integer
  296.     intZeroPos = InStr(strString, Chr$(0))
  297.     
  298.     If intZeroPos > 0 Then
  299.         StripTerminator = Left$(strString, intZeroPos - 1)
  300.     Else
  301.         StripTerminator = strString
  302.     End If
  303.     
  304. End Function
  305.  
  306.  
  307.  
  308.